home *** CD-ROM | disk | FTP | other *** search
/ Graphics Plus / Graphics Plus.iso / libs / phigs / ptk.lha / ptk / fortran / source / library / cns.f next >
Encoding:
Text File  |  1992-06-18  |  11.2 KB  |  391 lines
  1. C----------------------------------------------------------------------------
  2.  
  3. C Module name: colour naming scheme.
  4.  
  5. C Author: W.T. Hewitt.
  6.  
  7. C Function: provides an English-based interface for defining colour values.
  8.  
  9. C Hashtables used: "colourindex".
  10.  
  11. C Modification history: (Version), (Date), (Name), (Description).
  12.  
  13. C 1.0, ?????, W.T. Hewitt, First version.
  14.  
  15. C 2.0, 8th April 1991, J.G. Williams, Converted from FORTRAN to C.
  16.  
  17. C----------------------------------------------------------------------------
  18.  
  19.        SUBROUTINE ptkf_hsltorgb(hsl, rgb)
  20. C /*
  21. C ** \parambegin
  22. C ** \param{REAL}{hsl(3)}{HSL triplet}{IN}
  23. C ** \param{REAL}{rgb(3)}{RGB triplet}{IN}
  24. C ** \paramend
  25. C ** \blurb{This function converts from the HSL double-ended hexcone 
  26. C ** model to the 
  27. C ** RGB model. Given HSL, the equivalent RGB parameters are computed.
  28. C ** All parameters are assumed to be in the range 0.0 to 1.0. The
  29. C ** algorithm is adapted from~\cite{foley:fic}.}
  30. C */
  31.        REAL hsl(3), rgb(3)
  32.        external ptk_hsltorgb !$PRAGMA C(ptk_hsltorgb)
  33.  
  34.        call ptk_hsltorgb(hsl, rgb)
  35.  
  36.        RETURN
  37.        END
  38.  
  39.        SUBROUTINE ptkf_rgbtohsl(rgb, hsl)
  40. C /*
  41. C ** \parambegin
  42. C ** \param{REAL}{rgb(3)}{RGB triplet}{IN}
  43. C ** \param{REAL}{hsl(3)}{HSL triplet}{IN}
  44. C ** \paramend
  45. C ** \blurb{This function converts an RGB triplet to a HSL triplet.
  46. C ** The
  47. C ** algorithm is adapted from~\cite{watt:fotdcg}.}
  48. C */
  49.        REAL rgb(3), hsl(3)
  50.        external ptk_rgbtohsl !$PRAGMA C(ptk_rgbtohsl)
  51.  
  52.        call ptk_rgbtohsl(rgb, hsl)
  53.  
  54.        RETURN
  55.        END
  56.  
  57.        SUBROUTINE ptkf_hsvtorgb(hsv, rgb)
  58. C /*
  59. C ** \parambegin
  60. C ** \param{REAL}{hvs(3)}{HSV triplet}{IN}
  61. C ** \param{REAL}{rgb(3)}{RGB triplet}{IN}
  62. C ** \paramend
  63. C ** \blurb{This function converts a HSV triplet to a RGB triplet. 
  64. C ** The
  65. C ** algorithm is adapted from~\cite{watt:fotdcg}.}
  66. C */
  67.        REAL hsv(3), rgb(3)
  68.        external ptk_hsvtorgb !$PRAGMA C(ptk_hsvtorgb)
  69.  
  70.        call ptk_hsvtorgb(hsv, rgb)
  71.  
  72.        RETURN
  73.        END
  74.  
  75.        SUBROUTINE ptkf_rgbtohsv(rgb, hsv)
  76. C /*
  77. C ** \parambegin
  78. C ** \param{REAL}{rgb(3)}{RGB triplet}{IN}
  79. C ** \param{REAL}{hsv(3)}{HSV triplet}{IN}
  80. C ** \paramend
  81. C ** \blurb{This function converts an RGB value to a HSV value.
  82. C ** The
  83. C ** algorithm is adapted from~\cite{watt:fotdcg}.}
  84. C */
  85.        REAL rgb(3), hsv(3)
  86.        external ptk_rgbtohsv !$PRAGMA C(ptk_rgbtohsv)
  87.  
  88.        call ptk_rgbtohsv(rgb, hsv)
  89.  
  90.        RETURN
  91.        END
  92.  
  93.        LOGICAL FUNCTION ptkf_cnstorgb(colourname, rgb)
  94. C /*
  95. C ** \parambegin
  96. C ** \param{CHARACTER*(*)}{colourname}{colour description}{IN}
  97. C ** \param{REAL}{rgb(3)}{RGB triplet}{IN}
  98. C ** \paramend
  99. C ** \blurb{This function converts a CNS colour name to the equivalent
  100. C **  RGB value, returning TRUE if the conversion was successful,
  101. C ** and FALSE if not.}
  102. C */
  103.        CHARACTER*(*) colourname
  104.        REAL rgb(3)
  105.        LOGICAL*1 ptk_cnstorgb, ans
  106.        external ptk_cnstorgb !$PRAGMA C(ptk_cnstorgb)
  107.  
  108.        ans = ptk_cnstorgb(colourname, rgb)
  109.        if (ans .eq. 1) then
  110.           ptkf_cnstorgb = .TRUE.
  111.        else
  112.           ptkf_cnstorgb = .FALSE.
  113.        endif
  114.  
  115.        RETURN
  116.        END
  117.  
  118.        LOGICAL FUNCTION ptkf_cnstohsl(colourname, hsl)
  119. C /*
  120. C ** \parambegin
  121. C ** \param{CHARACTER*(*)}{colourname}{colour description}{IN}
  122. C ** \param{Pcobundl *}{hsl}{HSL triplet}{IN}
  123. C ** \paramend
  124. C ** \blurb{This function converts a CNS colour name to the equivalent
  125. C **  HSL value, returning TRUE if the conversion was successful,
  126. C ** and FALSE if not.}
  127. C */
  128.        CHARACTER*(*) colourname
  129.        REAL hsl(3)
  130.        LOGICAL*1 ptk_cnstohsl, ans
  131.        external ptk_cnstohsl !$PRAGMA C(ptk_cnstohsl)
  132.  
  133.        ans = ptk_cnstohsl(colourname, hsl)
  134.        if (ans .eq. 1) then
  135.           ptkf_cnstohsl = .TRUE.
  136.        else
  137.           ptkf_cnstohsl = .FALSE.
  138.        endif
  139.  
  140.        RETURN
  141.        END
  142.  
  143.        LOGICAL FUNCTION ptkf_cnstohsv(colourname, hsv)
  144. C /*
  145. C ** \parambegin
  146. C ** \param{CHARACTER*(*)}{colourname}{colour description}{IN}
  147. C ** \param{REAL}{hsv(3)}{HSV triplet}{IN}
  148. C ** \paramend
  149. C ** \blurb{This function Converts colour name to HSV.
  150. C ** Returns TRUE if ok, FALSE if not ok.}
  151. C */
  152.        CHARACTER*(*) colourname
  153.        REAL hsv(3)
  154.        LOGICAL*1 ptk_cnstohsv, ans
  155.        external ptk_cnstohsv !$PRAGMA C(ptk_cnstohsv)
  156.  
  157.        ans = ptk_cnstohsv(colourname, hsv)
  158.        if (ans .eq. 1) then
  159.           ptkf_cnstohsv = .TRUE.
  160.        else
  161.           ptkf_cnstohsv = .FALSE.
  162.        endif
  163.  
  164.        RETURN
  165.        END
  166.  
  167.        SUBROUTINE ptkf_setcnsdefaults(lightness, saturation)
  168. C /*
  169. C ** \parambegin
  170. C ** \param{INTEGER}{lightness}{default lightness for colours}{IN}
  171. C ** \param{INTEGER}{saturation}{default saturation for colours}{IN}
  172. C ** \paramend
  173. C ** \blurb{This function sets default values for lightness and
  174. C **  saturation for the  Colour Naming
  175. C ** Scheme. If lightness or saturation is missing when a 
  176. C ** colour name is subsequently specified, the
  177. C ** default is used.}
  178. C */
  179.        INTEGER lightness, saturation
  180.        external ptk_setcnsdefaults !$PRAGMA C(ptk_setcnsdefaults)
  181.  
  182.        call ptk_setcnsdefaults(%val(lightness), %val(saturation))
  183.  
  184.        RETURN
  185.        END
  186.  
  187.        SUBROUTINE ptkf_inqcnsdefaults(lightness, saturation)
  188. C /*
  189. C ** \parambegin
  190. C ** \param{INTEGER}{lightness}{default lightness for colours}{OUT}
  191. C ** \param{INTEGER}{saturation}{default saturation for colours}{OUT}
  192. C ** \paramend
  193. C ** \blurb{This function inquires the
  194. C **  default values of lightness and saturation used in the  Colour
  195. C ** Naming Scheme.}
  196. C */
  197.        INTEGER lightness, saturation
  198.        external ptk_inqcnsdefaults !$PRAGMA C(ptk_inqcnsdefaults)
  199.  
  200.        call ptk_inqcnsdefaults(lightness, saturation)
  201.  
  202.        RETURN
  203.        END
  204.  
  205.        SUBROUTINE ptkf_setcolourrep(wsid, colourname)
  206. C /*
  207. C ** \parambegin
  208. C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
  209. C ** \param{CHARACTER*(*)}{colourname}{colour name}{IN}
  210. C ** \paramend
  211. C ** \blurb{This function sets a colour representation in 
  212. C ** the colour table of workstation \pardesc{wsid},
  213. C **  using {\tt colourname}.
  214. C ** The hashstrings table
  215. C ** {\t "colourindex"} is used to derive the index to the colour table.}
  216. C */
  217.        INTEGER wsid
  218.        CHARACTER*(*) colourname
  219.        external ptk_setcolourrep !$PRAGMA C(ptk_setcolourrep)
  220.  
  221.        call ptk_setcolourrep(%val(wsid), colourname)
  222.  
  223.        RETURN
  224.        END
  225.  
  226.        SUBROUTINE ptkf_setrgbcolourname(colourname, rgb)
  227. C /*
  228. C ** \parambegin
  229. C ** \param{CHARACTER*(*)}{colourname}{colour name}{IN}
  230. C ** \param{REAL}{rgb(3)}{RGB colour value}{IN}
  231. C ** \paramend
  232. C ** \blurb{This function sets a colour representation in 
  233. C ** CNS using the colour name and
  234. C ** RGB value. The colour name must be different to the names provided by
  235. C ** the CNS. This function enables be  additional names for colours to
  236. C ** be specified in addition to those provided by CNS.}
  237. C */
  238.        CHARACTER*(*) colourname
  239.        REAL rgb(3)
  240.        external ptk_setrgbcolourname !$PRAGMA C(ptk_setrgbcolourname)
  241.  
  242.        call ptk_setrgbcolourname(colourname, rgb)
  243.  
  244.        RETURN
  245.        END
  246.  
  247.        SUBROUTINE ptkf_setbackgroundcolourind(wsid, index)
  248. C /*
  249. C ** \parambegin
  250. C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
  251. C ** \param{INTEGER}{index}{colour index}{IN}
  252. C ** \paramend
  253. C ** \blurb{This function sets the colour representation of the
  254. C **  zeroth entry in the
  255. C ** colour table of workstation \pardesc{wsid}, to be same as the
  256. C **  entry \pardesc{index} in the colour table.}
  257. C */
  258.        INTEGER wsid, index
  259.        external ptk_setbackgroundcolourind 
  260. & !$PRAGMA C(ptk_setbackgroundcolourind)
  261.  
  262.        call ptk_setbackgroundcolourind(%val(wsid), %val(index))
  263.  
  264.        RETURN
  265.        END
  266.  
  267.        SUBROUTINE ptkf_setbackgroundcolour(wsid, colourname)
  268. C /*
  269. C ** \parambegin
  270. C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
  271. C ** \param{CHARACTER*(*)}{colourname}{colour name}{IN}
  272. C ** \paramend
  273. C ** \blurb{This function sets the colour representation of the
  274. C **  zeroth entry in the
  275. C ** colour table of workstation \pardesc{wsid}, to be that
  276. C ** specified by \pardesc{colourname} in the CNS.}
  277. C */
  278.        INTEGER wsid
  279.        CHARACTER*(*) colourname
  280.        external ptk_setbackgroundcolour 
  281. & !$PRAGMA C(ptk_setbackgroundcolour)
  282.  
  283.        call ptk_setbackgroundcolour(%val(wsid), colourname)
  284.  
  285.        RETURN
  286.        END
  287.  
  288.        SUBROUTINE ptkf_setlinecolour(wsid, colourname)
  289. C /*
  290. C ** \parambegin
  291. C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
  292. C ** \param{CHARACTER*(*)}{colourname}{colour name}{IN}
  293. C ** \paramend
  294. C ** \blurb{This function sets the polyline colour index to be 
  295. C ** that specified by the given
  296. C ** colour name in the {\tt "colourindex"} hashtable. The colour 
  297. C ** representation
  298. C ** is set in the workstation colour table if necessary.}
  299. C */
  300.        INTEGER wsid
  301.        CHARACTER*(*) colourname
  302.        external ptk_setlinecolour !$PRAGMA C(ptk_setlinecolour)
  303.  
  304.        call ptk_setlinecolour(%val(wsid), colourname)
  305.  
  306.        RETURN
  307.        END
  308.  
  309.        SUBROUTINE ptkf_setmarkercolour(wsid, colourname)
  310. C /*
  311. C ** \parambegin
  312. C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
  313. C ** \param{CHARACTER*(*)}{colourname}{colour name}{IN}
  314. C ** \paramend
  315. C ** \blurb{This function sets the polymarker colour index to be 
  316. C ** that specified by the given
  317. C ** colour name in the {\tt "colourindex"} hashtable. The colour 
  318. C ** representation is set in the workstation colour table if necessary.}
  319. C */
  320.        INTEGER wsid
  321.        CHARACTER*(*) colourname
  322.        external ptk_setmarkercolour !$PRAGMA C(ptk_setmarkercolour)
  323.  
  324.        call ptk_setmarkercolour(%val(wsid), colourname)
  325.  
  326.        RETURN
  327.        END
  328.  
  329.        SUBROUTINE ptkf_setintcolour(wsid, colourname)
  330. C /*
  331. C ** \parambegin
  332. C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
  333. C ** \param{CHARACTER*(*)}{colourname}{colour name}{IN}
  334. C ** \paramend
  335. C ** \blurb{This function sets the interior colour index to be
  336. C ** that specified by the given
  337. C ** colour name in the {\tt "colourindex"} hashtable. The colour 
  338. C ** representation is set in the workstation colour table if necessary.}
  339. C */
  340.        INTEGER wsid
  341.        CHARACTER*(*) colourname
  342.        external ptk_setintcolour !$PRAGMA C(ptk_setintcolour)
  343.  
  344.        call ptk_setintcolour(%val(wsid), colourname)
  345.  
  346.        RETURN
  347.        END
  348.  
  349.        SUBROUTINE ptkf_setedgecolour(wsid, colourname)
  350. C /*
  351. C ** \parambegin
  352. C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
  353. C ** \param{CHARACTER*(*)}{colourname}{colour name}{IN}
  354. C ** \paramend
  355. C ** \blurb{This function sets the edge colour index to be 
  356. C ** that specified by the given
  357. C ** colour name in the {\tt "colourindex"} hashtable. The colour 
  358. C ** representation is set in the workstation colour table if necessary.}
  359. C */
  360.        INTEGER wsid
  361.        CHARACTER*(*) colourname
  362.        external ptk_setedgecolour !$PRAGMA C(ptk_setedgecolour)
  363.  
  364.        call ptk_setedgecolour(%val(wsid), colourname)
  365.  
  366.        RETURN
  367.        END
  368.  
  369.        SUBROUTINE ptkf_settextcolour(wsid, colourname)
  370. C /*
  371. C ** \parambegin
  372. C ** \param{INTEGER}{wsid}{workstation identifier}{IN}
  373. C ** \param{CHARACTER*(*)}{colourname}{colour name}{IN}
  374. C ** \paramend
  375. C ** \blurb{This function sets the text colour index to be 
  376. C ** that specified by the given
  377. C ** colour name in the {\tt "colourindex"} hashtable. The colour 
  378. C ** representation is set in the workstation colour table if necessary.}
  379. C */
  380.        INTEGER wsid
  381.        CHARACTER*(*) colourname
  382.        external ptk_settextcolour !$PRAGMA C(ptk_settextcolour)
  383.  
  384.        call ptk_settextcolour(%val(wsid), colourname)
  385.  
  386.        RETURN
  387.        END
  388.  
  389. C end of cns.f
  390.  
  391.